home *** CD-ROM | disk | FTP | other *** search
/ EnigmA Amiga Run 1999 March / EnigmA AMIGA RUN 35 (1999)(G.R. Edizioni)(IT)[!][issue 1999-03].iso / earcd / devel / wild / support / multicolordemo.bas < prev    next >
BASIC Source File  |  1999-01-01  |  3KB  |  167 lines
  1. SCREEN 1,320,256,3,1
  2. WINDOW 1,"Pyper MultiColor demo...",,,1
  3.  
  4. xa=100:ya=100:xb=200:yb=200
  5.  
  6. LINE (xa,ya)-(xb,yb),4,bf
  7. FOR i=xa TO xb STEP 2
  8. LINE (i,ya)-(i,yb),5
  9. NEXT i
  10. FOR j=ya TO yb STEP 2
  11. LINE (xa,j)-(xb,j),6
  12. NEXT j
  13. FOR i=xa TO xb STEP 2
  14.  FOR j=ya TO yb STEP 2
  15.   PSET (i,j),7
  16.  NEXT j
  17. NEXT i
  18. x=xa:sx=(xb-xa)/4
  19. FOR i=4 TO 7
  20.  LINE (x,ya-30)-(x+sx,ya-2),i,bf
  21.  x=x+sx
  22. NEXT i
  23.  
  24.  
  25. SUB SetRGB(c,r,g,b)
  26.  PALETTE c,r/255,g/255,b/255
  27. END SUB
  28.  
  29. RealR=&H9f
  30. RealG=&H4f
  31. RealB=&H6f
  32.  
  33. GOSUB ShowMC
  34.  
  35. FOR i=0 TO 255
  36.  RealR=i/1
  37.  RealG=i/2
  38.  RealB=i/8
  39.  GOSUB ShowMC
  40. NEXT i
  41.  
  42. FOR i=0 TO 255
  43.  RealR=RND(255)*255
  44.  RealG=RND(255)*255
  45.  RealB=RND(255)*255
  46.  GOSUB ShowMC
  47. NEXT i
  48.  
  49. END
  50.  
  51. ShowMC:
  52. CALL SetRGB(0,RealR,RealG,RealB)
  53.  
  54. ' Find color 1
  55. ' find the min component (r,g,b)
  56. ' find the deltas
  57.  
  58. FindR=RealR
  59. FindG=RealG
  60. FindB=RealB
  61. GOSUB FindBest
  62. Had1R=BestR
  63. Had1G=BestG
  64. Had1B=BestB
  65. CALL SetRGB(4,Had1R,Had1G,Had1B)
  66.  
  67. ' the remaining 3:
  68. ' rem*3+had1=4*real
  69. ' rem=(4*real-had1)/3
  70.  
  71. RemainR=4*RealR/3-(Had1R)/3
  72. RemainG=4*RealG/3-(Had1G)/3
  73. RemainB=4*RealB/3-(Had1B)/3
  74. FindR=RemainR
  75. FindG=RemainG
  76. FindB=RemainB
  77. GOSUB FindBest
  78. Had2R=BestR
  79. Had2G=BestG
  80. Had2B=BestB
  81. CALL SetRGB(5,Had2R,Had2G,Had2B)
  82.  
  83. RemainR=4*RealR/2-(Had1R+Had2R)/2
  84. RemainG=4*RealG/2-(Had1G+Had2G)/2
  85. RemainB=4*RealB/2-(Had1B+Had2B)/2
  86. FindR=RemainR
  87. FindG=RemainG
  88. FindB=RemainB
  89. GOSUB FindBest
  90. Had3R=BestR
  91. Had3G=BestG
  92. Had3B=BestB
  93. CALL SetRGB(6,Had3R,Had3G,Had3B)
  94.  
  95. RemainR=4*RealR-(Had1R+Had2R+Had3R)
  96. RemainG=4*RealG-(Had1G+Had2G+Had3G)
  97. RemainB=4*RealB-(Had1B+Had2B+Had3B)
  98. FindR=RemainR
  99. FindG=RemainG
  100. FindB=RemainB
  101. GOSUB FindBest
  102. Had4R=BestR
  103. Had4G=BestG
  104. Had4B=BestB
  105. CALL SetRGB(7,Had4R,Had4G,Had4B)
  106. 'LOCATE 1,1
  107. 'PRINT SPACE$(50)
  108. 'PRINT SPACE$(50)
  109. 'PRINT SPACE$(50)
  110. 'PRINT SPACE$(50)
  111. 'LOCATE 1,1
  112. 'PRINT "1";Had1R,Had1G,Had1B
  113. 'PRINT "2";Had2R,Had2G,Had2B
  114. 'PRINT "3";Had3R,Had3G,Had3B
  115. 'PRINT "4";Had4R,Had4G,Had4B
  116. ErrR=RealR-(Had1R+Had2R+Had3R+Had4R)/4
  117. ErrG=RealG-(Had1G+Had2G+Had3G+Had4G)/4
  118. ErrB=RealB-(Had1B+Had2B+Had3B+Had4G)/4
  119. LOCATE 1,1
  120. PRINT SPACE$(35)
  121. LOCATE 1,1
  122. PRINT ErrR,ErrG,ErrB
  123. RETURN
  124.  
  125. FindBest:
  126.  IF FindR>255 THEN FindR=255
  127.  IF FindG>255 THEN FindG=255
  128.  IF FindB>255 THEN FindB=255
  129.  MinC=FindR
  130.  IF FindG<MinC THEN MinC=FindG
  131.  IF FindB<MinC THEN MinC=FindB
  132.  MaxC=FindR
  133.  IF FindG>MaxC THEN MaxC=FindG
  134.  IF FindB>MaxC THEN MaxC=FindB
  135.  MaxS=0:MaxN=0
  136.  DeltaR=FindR-MinC
  137.  DeltaG=FindG-MinC
  138.  DeltaB=FindB-MinC
  139.  DeltaMax=(MaxC-MinC)/2
  140.  IF DeltaR>DeltaMax
  141.   MaxS=MaxS+FindR:MaxN=MaxN+1
  142.  END IF
  143.  IF DeltaG>DeltaMax
  144.   MaxS=MaxS+FindG:MaxN=MaxN+1
  145.  END IF
  146.  IF DeltaB>DeltaMax
  147.   MaxS=MaxS+FindB:MaxN=MaxN+1
  148.  END IF
  149.  IF MaxN>0
  150.   MaxS=MaxS/MaxN
  151.   IF DeltaR>DeltaMax THEN BestR=MaxS ELSE BestR=0
  152.   IF DeltaG>DeltaMax THEN BestG=MaxS ELSE BestG=0
  153.   IF DeltaB>DeltaMax THEN BestB=MaxS ELSE BestB=0
  154.  ELSE
  155.   MinS=(FindR+FindG+FindB)/3
  156.   BestR=MinS
  157.   BestB=MinS
  158.   BestG=MinS
  159.  END IF
  160. RETURN
  161.   
  162.  
  163.  
  164.  
  165.  
  166.  
  167.